home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / libr.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  43KB  |  1,446 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. /* libr - procedures for reading (in C format) ais and tre files*/
  10.  
  11. #include "hdr.h"
  12. #include "vars.h"
  13. #include "libhdr.h"
  14. #include "ifile.h"
  15. #include "dbxp.h"
  16. #include "chapp.h"
  17. #include "arithp.h"
  18. #include "dclmapp.h"
  19. #include "miscp.h"
  20. #include "smiscp.h"
  21. #include "setp.h"
  22. #include "libfp.h"
  23. #include "libp.h"
  24. #include "librp.h"
  25.  
  26. static void getlitmap(IFILE *, Symbol);
  27. static char *getmisc(IFILE *, Symbol, int);
  28. static void getrepr(IFILE * , Symbol);
  29. static void getnod(IFILE *, char *, Node, int);
  30. static void getnval(IFILE *, Node);
  31. static int *getuint(IFILE *, char *);
  32. static void getovl(IFILE *, Symbol);
  33. static void getsig(IFILE *, Symbol, int);
  34. static void getudecl(IFILE *, int);
  35. static Tuple add_tree_node(Tuple, Node);
  36. static void retrieve_tree_nodes(IFILE *, int, Tuple);
  37.  
  38. extern IFILE *TREFILE, *AISFILE, *STUBFILE, *LIBFILE;
  39.  
  40. Declaredmap getdcl(IFILE *ifile)            /*;getdcl*/
  41. {
  42.     Declaredmap d;
  43.     char    *id;
  44.     Symbol    sym;
  45.     int n = 0, vis, i;
  46.  
  47.     n = getnum(ifile, "dcl_is_map_defined");
  48.     if (n == 0) {
  49.         return (Declaredmap) 0;
  50.     }
  51.     n = getnum(ifile, "dcl-number-defined"); /* get item count */
  52.     d = dcl_new(n);
  53.     if (n == 0) return d;
  54.     for (i = 1; i <= n; i++) {
  55.         id = getstr(ifile, "sym-str");
  56.         sym = getsymref(ifile, "");
  57.         vis = getnum(ifile, "sym-vis");
  58.         dcl_put_vis(d, id, sym, vis);
  59.     }
  60.     return(d);
  61. }
  62.  
  63. static void getlitmap(IFILE *ifile, Symbol sym)                /*;gettlitmap*/
  64. /* called for na_enum to input literal map.
  65.  * The literal map is a tuple, entries consisting of string followed
  66.  * by integer.
  67.  */
  68. {
  69.     Tuple    tup;
  70.     int i, n;
  71.  
  72.     n = getnum(ifile, "litmap-n");
  73.     tup = tup_new(n);
  74.     for (i = 1; i <= n; i+=2) {
  75.         tup[i] = getstr(ifile, "litmap-str");
  76.         tup[i+1] = (char *) getnum(ifile, "litmap-value");
  77.     }
  78.     OVERLOADS(sym) = (Set) tup;
  79. }
  80.  
  81. static char *getmisc(IFILE *ifile, Symbol sym, int mval)            /*;getmisc*/
  82. {
  83.     /* read MISC information if present 
  84.  * MISC is integer except for package, in which case it is a triple.
  85.  * The first two components are integers, the last is  a tuple of
  86.  * symbols
  87.  */
  88.     int    nat, i, n;
  89.     Tuple  tup, stup;
  90.  
  91.     nat = NATURE(sym);
  92.     if ((nat == na_package || nat == na_package_spec)) {
  93.         if (mval) {
  94.             tup = tup_new(3);
  95.             tup[1] = (char *) getnum(ifile, "misc-package-1");
  96.             tup[2] = (char *) getnum(ifile, "misc-package-2");
  97.             n = getnum(ifile, "misc-package-tupsize");
  98.             stup = tup_new(n);
  99.             for (i = 1; i<= n; i++)
  100.                 stup[i] = (char *) getsymref(ifile, "misc-package-symref");
  101.             tup[3] = (char *) stup;
  102.             return (char *) tup;
  103.         }
  104.         else {
  105.             getnum(ifile, "misc");
  106.             return  (char *)MISC(sym);
  107.         }
  108.     }
  109.     else if ((nat == na_procedure || nat == na_function) && mval) {
  110.         tup = tup_new(2);
  111.         tup[1] = (char *) getnum(ifile, "misc-number");
  112.         tup[2] = (char *) getsymref(ifile, "misc-symref");
  113.         return (char *) tup;
  114.     }
  115.     else {
  116.         return  (char *)getnum(ifile, "misc");
  117.     }
  118. }
  119. static void getrepr(IFILE * ifile, Symbol sym)            /*;getrepr*/
  120. {
  121.     /* read int representation information if present */
  122.  
  123.     int     repr_tag, i, n;
  124.     Tuple     align_mod_tup,align_tup,repr_tup;
  125.     Tuple     tup4;
  126.  
  127.     repr_tag = getnum(ifile, "repr-type");
  128.     if (repr_tag != -1) {
  129.             if (repr_tag == TAG_RECORD)     { /* record type */
  130.                 repr_tup = tup_new(4);
  131.                 repr_tup[1] = (char *) TAG_RECORD;
  132.                    repr_tup[2] = (char *) getnum(ifile,"repr-rec-size");
  133.                 align_mod_tup = tup_new(2);
  134.                 align_mod_tup[1] = (char *) getnum(ifile,"repr-rec-mod");
  135.                 n = getnum(ifile,"repr-align_tup_size");
  136.                 align_tup = tup_new(0);
  137.                 for (i=1; i<=n; i++) {
  138.                     tup4 = tup_new(4);
  139.                     tup4[1] = (char *) getsymref(ifile,"repr-rec-align-1");
  140.                     tup4[2] = (char *) getnum(ifile,"repr-rec-align-2");
  141.                     tup4[3] = (char *) getnum(ifile,"repr-rec-align-3");
  142.                     tup4[4] = (char *) getnum(ifile,"repr-rec-align-4");
  143.                     align_tup = tup_with(align_tup, (char *) tup4);
  144.                 }
  145.                 align_mod_tup[2] = (char *) align_tup;
  146.                    repr_tup[4] = (char *) align_mod_tup;
  147.                 REPR(sym) = repr_tup;
  148.             }
  149.             else if (repr_tag == TAG_ACCESS || 
  150.                      repr_tag == TAG_TASK) { /* access or task type */
  151.                 repr_tup = tup_new(3);
  152.                 repr_tup[1] = (char *) repr_tag;
  153.                  repr_tup[2] = (char *) getnum(ifile, "repr-size-2");
  154.                 repr_tup[3] = (char *) getnodref(ifile, "repr-storage-size");
  155.                 REPR(sym) = repr_tup;
  156.             }
  157.             else {         /* non-record, non-access, non-task type */
  158.                 n = getnum(ifile, "repr-tup-size");
  159.                 repr_tup = tup_new(n);
  160.                 repr_tup[1] = (char *) repr_tag;
  161.                 for (i=2; i <= n; i++)
  162.                     repr_tup[i] = (char *) getnum(ifile, "repr-info");
  163.                 REPR(sym) = repr_tup;
  164.             }
  165.     }
  166. }
  167.  
  168.  
  169. static void getnod(IFILE *ifile, char *desc, Node node, int unum)    /*;getnod*/
  170. {
  171.     /* 
  172.      * Read information for the node from a file (ifile)
  173.      * Since all the nodes in the tree all have the same N_UNIT value, 
  174.      * the node can be read from the file in a more compact format.
  175.      * The N_UNIT of the node itself and of its children (N_AST1...) need not
  176.      * be read only their N_SEQ filed needs to be read. There is one 
  177.      * complication of this scheme. OPT_NODE which is (seq=1, unit=0) will
  178.      * conflict with (seq=1,unit=X)  of current unit. Therefore, in this case a 
  179.      * sequence # of -1 will signify OPT_NODE.
  180.      */
  181.     int i;
  182.     short    nk, num1, num2, has_n_list;
  183.     Tuple    ltup;
  184.     short    fnum[24], fnums, fnumr=0;
  185.  
  186.     /* copy standard info */
  187.     fnums = getnum(ifile, desc);
  188.     /*fread((char *) &fnums, sizeof(short), 1, ifile->fh_file);*/
  189.     fread((char *) fnum,  sizeof(short), fnums, ifile->fh_file);
  190.     if (fnums == 0) {
  191.         chaos("getnod-fnums-zero");
  192.     }
  193.     fnumr = 0;
  194.     nk = fnum[fnumr++];
  195.     N_KIND(node) = nk;
  196.     N_SEQ(node) = fnum[fnumr++];
  197.     N_UNIT(node) = unum;
  198. #ifdef DEBUG
  199.     if (trapns>0 && N_SEQ(node)== trapns && N_UNIT(node) == trapnu) trapn(node);
  200. #endif
  201.  
  202.     N_SPAN0(node) = N_SPAN1(node) = 0;
  203.  
  204.     if (N_LIST_DEFINED(nk)) {
  205.         has_n_list = fnum[fnumr++];
  206.         ltup = (has_n_list) ? tup_new(has_n_list - 1) : (Tuple) 0;
  207.     }
  208.     else {
  209.         has_n_list = 0;
  210.     }
  211.     /* ast fields */
  212.     /* See comment above for description of compact format of node */
  213.     N_AST1(node) = N_AST2(node) = N_AST3(node) = N_AST4(node) = (Node)0;
  214.     if (N_AST1_DEFINED(nk)) {
  215.         num1 = fnum[fnumr++];
  216.         N_AST1(node) = (num1 == -1) ? OPT_NODE : getnodptr(num1, unum);
  217.     }
  218.     if (N_AST2_DEFINED(nk)) {
  219.         num1 = fnum[fnumr++];
  220.         N_AST2(node) = (num1 == -1) ? OPT_NODE : getnodptr(num1, unum);
  221.     }
  222.     if (N_AST3_DEFINED(nk)) {
  223.         num1 = fnum[fnumr++];
  224.         N_AST3(node) = (num1 == -1) ? OPT_NODE : getnodptr(num1, unum);
  225.     }
  226.     if (N_AST4_DEFINED(nk)) {
  227.         num1 = fnum[fnumr++];
  228.         N_AST4(node) = (num1 == -1) ? OPT_NODE : getnodptr(num1, unum);
  229.     }
  230.  
  231.     if (N_UNQ_DEFINED(nk)) {
  232.         num1 = fnum[fnumr++]; 
  233.         num2 = fnum[fnumr++];
  234.         if (num1>0 || num2>0)
  235.             N_UNQ(node) = getsymptr(num1, num2);
  236.     }
  237.     if (N_TYPE_DEFINED(nk)) {
  238.         num1 = fnum[fnumr++]; 
  239.         num2 = fnum[fnumr++];
  240.         if (num1>0 || num2>0) {
  241.             N_TYPE(node) = getsymptr(num1, num2);
  242.         }
  243.     }
  244.  
  245.     /* read out n_list if needed */
  246.     if (has_n_list > 0) {
  247.         for (i = 1; i<has_n_list; i++) {
  248.             ltup[i] = (char *) getnodref(ifile, "n-list-nodref");
  249.         }
  250.         if (ltup != (Tuple)0) {
  251.             N_LIST(node) = ltup;
  252.         }
  253.     }
  254.     if (N_VAL_DEFINED(nk))
  255.         getnval(ifile, node);
  256. }
  257.  
  258. Node getnodref(IFILE *ifile, char *desc)            /*;getnodref*/
  259. {
  260.     Node    node;
  261.     int    seq, unit;
  262.  
  263.     /* 
  264.      * OPT_NODE is node in unit 0 with sequence 1, and needs
  265.      * no special handling here
  266.      */
  267.     seq = getnum(ifile, "nref-seq");
  268.     unit = getnum(ifile, "nref-unt");
  269.     if (seq == 1 && unit == 0) {
  270.         return OPT_NODE;
  271.     }
  272.     else {
  273.         node = getnodptr(seq, unit);
  274. #ifdef DEBUG
  275.         if (trapns>0 && trapns == seq && trapnu == unit) trapn(node);
  276. #endif
  277.     }
  278.     return node;
  279. }
  280.  
  281. static void getnval(IFILE *ifile, Node node)                /*;getnval*/
  282. {
  283.     /* read N_VAL field for node to AISFILE */
  284.     int        nk, ck;
  285.     Const    con;
  286.     char    *nv;
  287.     Tuple    tup;
  288.     int        i, n, *rn, *rd;
  289.     double    doub;
  290.     Symbolmap   smap;
  291.     Symbol    s1, s2;
  292.  
  293.     nv = NULL;       /* gs nov 1: added to avoid setting N_VAL incorrectly
  294.                         at end of this routine */
  295.     switch (nk = N_KIND(node)) {
  296.       case    as_simple_name:
  297.       case    as_int_literal:
  298.       case    as_real_literal:
  299.       case    as_string_literal:
  300.       case    as_character_literal:
  301.       case    as_subprogram_stub_tr:
  302.       case    as_package_stub:
  303.       case    as_task_stub:
  304.                 nv = (char *) getstr(ifile, "nval-name");
  305.                 break;
  306.       case    as_line_no:
  307.       case    as_number:
  308.       case    as_predef:
  309.                 nv = (char *) getnum(ifile, "nval-int");
  310.                 break;
  311.       case    as_mode:
  312.                 /* convert mode, indeed, the inverse of change made in astread*/
  313.                 nv = (char *) getnum(ifile, "nval-mode");
  314.                 break;
  315.       case    as_ivalue:
  316.                 ck = getnum(ifile, "nval-const-kind");
  317.                 con = const_new(ck);
  318.                 nv = (char *) con;
  319.                 switch (ck) {
  320.                   case    CONST_INT:
  321.                     con->const_value.const_int =
  322.                       getint(ifile, "nval-const-int-value");
  323.                     break;
  324.                   case    CONST_REAL:
  325.                     fread((char *) &doub, sizeof(double), 1, ifile->fh_file);
  326.                     con->const_value.const_real = doub;
  327.                     break;
  328.                   case    CONST_UINT:
  329.                     con->const_value.const_uint =
  330.                       getuint(ifile, "nval-const-uint");
  331.                     break;
  332.                   case    CONST_OM:
  333.                     break; /* no further data needed if OM */
  334.                   case    CONST_RAT:
  335.                     rn = getuint(ifile, "nval-const-rat-num");
  336.                     rd = getuint(ifile, "nval-const-rat-den");
  337.                     con->const_value.const_rat = rat_fri(rn, rd);
  338.                     break;
  339.                   case    CONST_CONSTRAINT_ERROR:
  340.                     break;
  341.                 };
  342.                 break;
  343.       case    as_terminate_alt:
  344.                 /*: terminate_statement (9)  nval is depth_count (int)*/
  345.                 nv = (char *) getnum(ifile, "nval-terminate-depth");
  346.                 break;
  347.       case    as_string_ivalue:
  348.                 /* nval is tuple of integers */
  349.                 n = getnum(ifile, "nval-string-ivalue-size");
  350.                 tup     = tup_new(n);
  351.                 for (i = 1;i <= n; i++)
  352.                     tup[i] = (char *)getchr(ifile, "nval-string-ivalue");
  353.                 nv = (char *) tup;
  354.                 break;
  355.       case    as_instance_tuple:
  356.                 n = getnum(ifile, "nval-instance-size");
  357.                 if (n != 0) {
  358.                     if (n != 2)
  359.                         chaos("getnval: bad nval for instantiation");
  360.                     tup = tup_new(n);
  361.                     /* first component is instance map */
  362.                     n = getnum(ifile, "nval-symbolmap-size");
  363.                     smap = symbolmap_new();
  364.                     for (i = 1; i <= n/2; i++) {
  365.                         s1 = getsymref(ifile, "symbolmap-1");
  366.                         s2 = getsymref(ifile, "symbolmap-2");
  367.                         symbolmap_put(smap, s1, s2);
  368.                     }
  369.                     tup[1] = (char *)smap;
  370.                     /* second component is needs_body flag */
  371.                     tup [2] = (char *)getnum(ifile, "nval-flag");
  372.                     nv = (char *)tup;
  373.                 }
  374.                 else nv = NULL;
  375.                 break;
  376.     };
  377.  
  378.     if (N_VAL_DEFINED(nk)) N_VAL(node) = nv;
  379.     if (N_VAL_DEFINED(nk) == FALSE && nv != NULL) {
  380.         chaos("libr.c: nval exists, but N_VAL_DEFINED not");
  381.     }
  382.  
  383.     /* need to handle following cases:
  384. as_simple_name:
  385.     otherwise    identifier string
  386.  
  387.     procedure package_instance (12)
  388.       this procedure builds a node of type as_simple_name
  389.       with N_VAL a symbol pointeger.
  390. as_pragma??
  391. as_array aggregate
  392. as_generic: (cf. 12)
  393.  
  394.  */
  395.  
  396. }
  397.  
  398. static int *getuint(IFILE *ifile, char *desc)                /*;getuint*/
  399. {
  400.     int n, *res;
  401.     n = getnum(ifile, "uint-size");
  402.     res = (int *) ecalloct((unsigned)n+1, sizeof(int), "getuint");
  403.     fread((char *) res, sizeof(int), n+1, ifile->fh_file);
  404.     return res;
  405. }
  406.  
  407. static void getovl(IFILE *ifile, Symbol sym)                /*;getovl*/
  408. {
  409.     int        nat, n, i;
  410.     Set        ovl;
  411.     Private_declarations    pd;
  412.     Tuple    tup;
  413.  
  414.     nat = NATURE(sym);
  415.     ovl = (Set) 0;
  416.     /* 
  417.      * It is the private declarations for na_package and na_package_spec,
  418.      * and na_generic_package_spec.
  419.      * Otherwise it is a set of symbols:
  420.      *    na_aggregate  na_entry    na_function  na_function_spec
  421.      *    na_literal  na_op  na_procedure     na_procedure_spec
  422.      * It is literal map for enumeration type (na_enum).
  423.      */
  424.     if(nat == na_enum) {
  425.         getlitmap(ifile, sym);
  426.         return;
  427.     }
  428.     else if (nat == na_package || nat == na_package_spec
  429.       || nat == na_generic_package_spec || nat == na_generic_package
  430.       || nat == na_task_type || nat == na_task_obj) {
  431.         /* read in private declarations (rebuild tuple) */
  432.         n = getnum(ifile, "ovl-private-decls-size");
  433.         pd = private_decls_new(n);
  434.         tup = tup_new(n+n);
  435.         for (i = 1; i <= n; i++) {
  436.             tup[2*i-1] =  (char *) getsym(ifile, "ovl-pdecl-1-sym");
  437.             tup[2*i] =  (char *) getsym(ifile, "ovl-pdecl-2-sym");
  438.         }
  439.         pd->private_declarations_tuple = tup;
  440.         ovl = (Set) pd;
  441.     }
  442.     else {     /* if (ovl != (Set)0) */
  443.         /* this is condition for write, but for read, we call this routine */
  444.          /* iff overloads field is defined     (gs Nov 9 ) */
  445.         n = getnum(ifile, "ovl-set-size");
  446.         ovl = set_new(n);
  447.         for (i = 1; i <= n; i++)
  448.             ovl = set_with(ovl, (char *) getsymref(ifile, "ovl-set-symref"));
  449.     }
  450.     if (nat != na_package || SCOPE_OF(sym) != symbol_standard0)
  451.         /* otherwise the private dcls are inherited from the spec.*/
  452.         OVERLOADS(sym) = ovl;
  453. }
  454.  
  455. static void getsig(IFILE *ifile, Symbol sym, int is_private)        /*;getsig*/
  456. {
  457.     int nat, i, n;
  458.     Tuple    sig, tup, sigtup;
  459.     Node    node;
  460.     Symbol    s, s2;
  461.  
  462.     /* The signature field is used as follows:
  463.      * It is a symbol for:
  464.      *    na_access
  465.      * It is a node for
  466.      *    na_constant  na_in  na_inout
  467.      * It is also a node (always OPT_NODE) for na_out. For now we read this
  468.      * out even though it is not used. 
  469.      * It is a pair for na_array.
  470.      * It is a triple for na_enum.
  471.      * It is a triple for na_generic_function_spec na_generic_procedure_spec
  472.      * The first component is a tuple of pairs, each pair consisting of
  473.      * a symbol and a (default) node.
  474.      * The second component is a tuple of symbols.
  475.      * The third component is a node.
  476.      * It is a tuple with four elements for na_generic_package_spec:
  477.      * the first is a tuple of pairs, with same for as for generic procedure.
  478.      * the second third,and fourth components are nodes.
  479.      *    (see libw.c for format)
  480.      * It is a 5-tuple for na_record.
  481.      * It is a constraint for na_subtype and na_type.
  482.      * It is a node for na_obj.
  483.      * It is a tuple of nodes for na_task_type, na_task_type_spec
  484.      * Otherwise it is the signature for a procedure, namely a tuple
  485.      * of quadruples.
  486.      * In the expand tasks are converted to procedures so their signature is
  487.      * like that of procs.
  488.      */
  489.  
  490.     nat = NATURE(sym);
  491.     /* is_private indicates signature has form of that for record */
  492.     if (is_private) nat=na_record;
  493.  
  494.     switch (nat) {
  495.       case    na_access:
  496.                 /* access: signature is designated_type;*/
  497.                 sig = (Tuple) getsymref(ifile, "sig-access-symref");
  498.                 break;
  499.       case    na_array:
  500. array_case:
  501.                 /* array: signature is pair [i_types, comp_type] where
  502.                  * i_types is tuple of type names
  503.                  */
  504.                 sig = tup_new(2);
  505.                 n = getnum(ifile, "sig-array-itypes-size");
  506.                 tup = tup_new(n);
  507.                 for (i = 1; i <= n; i++)
  508.                     tup[i] = (char *)getsymref(ifile, "sig-array-i-types-type");
  509.                 sig[1] = (char *) tup;
  510.                 sig[2] = (char *) getsymref(ifile, "sig-array-comp-type");
  511.                 break;
  512.       case    na_block:
  513.                 /* block: miscellaneous information */
  514.                 /* This information not needed externally*/
  515.                 chaos("getsig: signature for block");
  516.                 break;
  517.       case    na_constant:
  518.       case    na_in:
  519.       case    na_inout:
  520.       case    na_out:
  521.       case    na_discriminant:
  522.                 sig = (Tuple) getnodref(ifile, "sig-discriminant-nodref");
  523.                 break;
  524.       case    na_entry:
  525.       case    na_entry_family:
  526.       case    na_entry_former:
  527.       /* entry: list of symbols */
  528.       case    na_function:
  529.       case    na_function_spec:
  530.       case    na_literal:
  531.       case    na_op:
  532.       case    na_procedure:
  533.       case    na_procedure_spec:
  534.       case    na_task_body:
  535.                 n = getnum(ifile, "sig-tuple-size");
  536.                 sig = tup_new(n);
  537.                 for (i = 1; i <= n; i++)
  538.                     sig[i] = (char *) getsymref(ifile, "sig-tuple-symref");
  539.                 break;
  540.       case    na_enum:
  541.                 /* enum: tuple in form ['range', lo, hi]*/
  542.                 /* we read this as two node references*/
  543.                 sig = tup_new(3);
  544.                 /*sig[1] = ???;*/
  545.                 sig[2] = (char *) getnodref(ifile, "sig-enum-low-nodref");
  546.                 sig[3] = (char *) getnodref(ifile, "sig-enum-high-nodref");
  547.                 break;
  548.       case    na_type:
  549. #ifdef TBSL
  550.                 s  = TYPE_OF(sym);
  551.                 s2 = TYPE_OF(root_type(sym));
  552.                 if ((s != (Symbol)0 && NATURE(s) == na_access) || 
  553.                     (s2 != (Symbol)0 && NATURE(s2) == na_access))  {
  554.                     getsymref(ifile, "sig-access-symref");
  555.                     break;
  556.                 }
  557. #endif
  558.                             i = getnum(ifile, "sig-type-is-access");
  559.                             if (i == 1) break; 
  560.                 /* for private types, is_private will be true, and
  561.                 *  signature is that of record 
  562.                  */
  563.                 n = getnum(ifile, "sig-type-size");
  564.                 i = getnum(ifile, "sig-constraint-kind");
  565.                 sig = tup_new(n);
  566.                 sig[1] = (char *) i;
  567.                 for (i=2; i <= n; i++)
  568.                     sig[i] = (char *) getnodref(ifile, "sig-type-nodref");
  569.                 break;
  570.       case na_subtype:
  571.                 n = getnum(ifile, "sig-subtype-size");
  572.                 i = getnum(ifile, "sig-constraint-kind");
  573.                 if (i == CONSTRAINT_ARRAY) goto array_case;
  574.                 sig = tup_new(n);
  575.                 sig[1] = (char *) i;
  576.                 if (i == CONSTRAINT_DISCR) {
  577.                     /* discriminant map */
  578.                     n = getnum(ifile, "sig-constraint-discrmap-size");
  579.                     tup = tup_new(n);
  580.                     for (i = 1; i <= n; i+=2) {
  581.                         tup[i] = (char *)getsymref(ifile,
  582.                           "sig-constraint-discr-map-symref");
  583.                         tup[i+1] = (char *)getnodref(ifile,
  584.                           "sig-constraint-discr-map-nodref");
  585.                     }
  586.                     sig[2] = (char *) tup;
  587.                 }
  588.                 else if (i == CONSTRAINT_ACCESS) {
  589.                     sig[2] = (char *)getsymref(ifile, "sig-subtype-acc-symref");
  590.                 }
  591.                 else {
  592.                     for (i=2; i <= n; i++)
  593.                         sig[i] = (char *)getnodref(ifile, "sig-subtype-nodref");
  594.                 }
  595.                 break;
  596.       case    na_generic_function:
  597.       case    na_generic_procedure:
  598.       case    na_generic_function_spec:
  599.       case    na_generic_procedure_spec:
  600.                 sig = tup_new(4);
  601.                 if (tup_size(sig) != 4) chaos(
  602.                     "getsig: bad signature for na_generic_procedure_spec");
  603.                 /* tuple count known to be four, just put elements */
  604.                 /* the first component is a tuple of pairs, just read count
  605.                  * and the values of the successive pairs 
  606.                  */
  607.                 n = getnum(ifile, "sig-generic-size");
  608.                 sigtup = tup_new(n);
  609.                 for (i = 1;i <= n; i++) {
  610.                     tup = tup_new(2);
  611.                     tup[1] = (char *) getsymref(ifile, "sig-generic-symref");
  612.                     tup[2] = (char *) getnodref(ifile, "sig-generic-nodref");
  613.                     sigtup[i] = (char *) tup;
  614.                 }
  615.                 sig[1] = (char *) sigtup;
  616.                 n = getnum(ifile, "sig-generic-typ-size"); /* symbol list */
  617.                 tup = tup_new(n);
  618.                 for (i = 1;i <= n; i++)
  619.                     tup[i] = (char *) getsymref(ifile,
  620.                       "sig-generic-symbol-symref");
  621.                 sig[2] = (char *) tup;
  622.                 node = getnodref(ifile, "sig-generic-3-nodref");
  623.                 if (nat == na_generic_procedure || nat == na_generic_function)
  624.                     sig[3] = (char *) node;
  625.                 else sig[3] = (char *) OPT_NODE;
  626.                 /* the four component is tuple of must_constrain symbols */
  627.                 n = getnum(ifile, "sig-generic-package-tupsize");
  628.                 tup = tup_new(n);
  629.                 for (i = 1;i <= n; i++)
  630.                     tup[i] = (char *) getsymref(ifile,
  631.                       "sig-generic-package-symref");
  632.                 sig[4] = (char *) tup;
  633.                 break;
  634.       case    na_generic_package_spec:
  635.       case    na_generic_package:
  636.                 /* signature is tuple with four elements */
  637.                 sig = tup_new(5);
  638.                 /* the first component is a tuple of pairs, just write count
  639.                  * and the values of the successive pairs 
  640.                  */
  641.                 n = getnum(ifile, "sig-generic-package-tupsize");
  642.                 tup = tup_new(n);
  643.                 for (i = 1;i <= n; i++) {
  644.                     sigtup = tup_new(2);
  645.                     sigtup[1] = (char *) getsymref(ifile,
  646.                       "sig-generic-package-symref");
  647.                     sigtup[2] = (char *) getnodref(ifile,
  648.                       "sig-generic-package-nodref");
  649.                     tup[i] = (char *) sigtup;
  650.                 }
  651.                 sig[1] = (char *) tup;
  652.                 /* the second third, and fourth components are just nodes */
  653.                 sig[2] = (char *) getnodref(ifile, "sig-generic-node-2");
  654.                 sig[3] = (char *) getnodref(ifile, "sig-generic-node-3");
  655.                 sig[4] = (char *) getnodref(ifile, "sig-generic-node-4");
  656.                 /* the fifth component is tuple of must_constrain symbols */
  657.                 n = getnum(ifile, "sig-generic-package-tupsize");
  658.                 tup = tup_new(n);
  659.                 for (i = 1;i <= n; i++)
  660.                     tup[i] = (char *) getsymref(ifile,
  661.                       "sig-generic-package-symref");
  662.                 sig[5] = (char *) tup;
  663.                 break;
  664.       case    na_record:
  665.                 /* the signature is tuple with five components:
  666.                  * [node, node, tuple of symbols, declaredmap, node]
  667.                  * NOTE: we do not read component count - 5 assumed 
  668.                  */
  669.                 sig = tup_new(5);
  670.                 sig[1] = (char *) getnodref(ifile, "sig-record-1-nodref");
  671.                 sig[2] = (char *) getnodref(ifile, "sig-record-2-nodref");
  672.                 n = getnum(ifile, "sig-record-3-size");
  673.                 tup = tup_new(n);
  674.                 for (i = 1; i <= n; i++)
  675.                     tup[i] = (char *) getsymref(ifile, "sig-record-3-nodref");
  676.                 sig[3]= (char *) tup;
  677.                 sig[4] = (char *) getdcl(ifile);
  678.                 sig[5] = (char *) getnodref(ifile, "sig-record-5-nodref");
  679.                 break;
  680.       case    na_void:
  681.                 /* special case assume entry for $used, in which case is tuple
  682.                  * of symbols
  683.                  */
  684.                 if (streq(ORIG_NAME(sym), "$used") ) {
  685.                     n = getnum(ifile, "sig-$used-size");
  686.                     sig = tup_new(n);
  687.                     for (i = 1; i <= n; i++)
  688.                         sig[i] = (char *) getsymref(ifile, "sig-$used-symref");
  689.                 }
  690.                 else {
  691. #ifdef DEBUG
  692.                     zpsym(sym);
  693. #endif
  694.                     chaos("getsig: na_void, not $used");
  695.                 }
  696.                 break;
  697.       case    na_obj:
  698.                 sig = (Tuple) getnodref(ifile, "sig-obj-nodref");
  699.                 break;
  700.       case    na_task_type:
  701.       case    na_task_type_spec:
  702.                 /* a tuple of nodes */
  703.                 n = getnum(ifile, "task-type-spec-size");
  704.                 sig = tup_new(n);
  705.                 for (i = 1; i <= n; i++)
  706.                     sig[i] = (char *)getnodref(ifile, "sig-task-nodref");
  707.                 break;
  708.     default:
  709. #ifdef DEBUG
  710.                 printf("getsig: default error\n");
  711.                 zpsym(sym);
  712. #endif
  713.                 chaos("getsig: default");
  714.     } /* End of switch */
  715.     SIGNATURE(sym) = sig;
  716. }
  717.  
  718. Symbol getsym(IFILE *ifile, char *desc)                                /*;getsym*/
  719. {
  720.     Symbol    sym, tmp_sym;
  721.     struct f_symbol_s fs;
  722.     int i, nat, is_private;
  723.  
  724.     /* read description for symbol sym to input file */
  725.     fread((char *) &fs, sizeof(f_symbol_s), 1, ifile->fh_file);
  726.     sym = getsymptr(fs.f_symbol_seq, fs.f_symbol_unit);
  727.     nat = fs.f_symbol_nature;
  728.     NATURE(sym) = nat;
  729.     S_SEQ(sym) = fs.f_symbol_seq;
  730.     S_UNIT(sym) = fs.f_symbol_unit;
  731. #ifdef DEBUG
  732.     if (trapss>0 && trapss == fs.f_symbol_seq 
  733.         && trapsu == fs.f_symbol_unit) traps(sym);
  734. #endif
  735.     TYPE_OF(sym) = getsymptr(fs.f_symbol_type_of_seq,
  736.         fs.f_symbol_type_of_unit);
  737.     SCOPE_OF(sym) = getsymptr(fs.f_symbol_scope_of_seq,
  738.         fs.f_symbol_scope_of_unit);
  739.     ALIAS(sym) = getsymptr(fs.f_symbol_alias_seq,
  740.         fs.f_symbol_alias_unit);
  741.     if (fs.f_symbol_type_attr & TA_ISPRIVATE) {
  742.         is_private = TRUE;
  743.         fs.f_symbol_type_attr ^= TA_ISPRIVATE; /* turn off ISPRIVATE bit*/
  744.     }
  745.     else {
  746.         is_private = FALSE;
  747.     }
  748.     TYPE_ATTR(sym) = fs.f_symbol_type_attr;
  749.     ORIG_NAME(sym) = getstr(ifile, "orig-name");
  750.     /* process overloads separately due to variety of cases */
  751.     if (fs.f_symbol_overloads) getovl(ifile, sym);
  752.  
  753.     /* read out declared map, treating na_enum case separately */
  754.     if (fs.f_symbol_declared) DECLARED(sym)= getdcl(ifile);
  755.  
  756.     /* signature */
  757.     if (fs.f_symbol_signature) getsig(ifile, sym, is_private);
  758.  
  759.     MISC(sym) = getmisc(ifile, sym, fs.f_symbol_misc);
  760.  
  761.     /* the following fields are extracted for the code generator use only */
  762.     if (TYPE_KIND(sym)  ==  0) TYPE_KIND(sym) = fs.f_symbol_type_kind;
  763.     if (TYPE_SIZE(sym) == 0) TYPE_SIZE(sym) = fs.f_symbol_type_size;
  764.     if (is_type(sym))
  765.         INIT_PROC(sym) = getsymptr(fs.f_symbol_init_proc_seq,
  766.           fs.f_symbol_init_proc_unit);
  767.     else          /* formal_decl_tree for subprogram specs */
  768.         INIT_PROC(sym) = (Symbol) getnodptr(fs.f_symbol_init_proc_seq,
  769.           fs.f_symbol_init_proc_unit);
  770.     if (ASSOCIATED_SYMBOLS(sym) != (Tuple)0) {
  771.         for (i = 1; i<fs.f_symbol_assoc_list; i++) {
  772.             tmp_sym = (Symbol) getsymref(ifile, "assoc-symbol-symref");
  773.             if (tmp_sym != (Symbol)0)
  774.                 ASSOCIATED_SYMBOLS(sym)[i] = (char *) tmp_sym;
  775.         }
  776.     }
  777.     else {
  778.         if (fs.f_symbol_assoc_list == 0)
  779.             ASSOCIATED_SYMBOLS(sym) = (Tuple) 0;
  780.         else 
  781.             ASSOCIATED_SYMBOLS(sym) = tup_new(fs.f_symbol_assoc_list -1);
  782.         if (fs.f_symbol_assoc_list > 1) {
  783.             for (i = 1; i<fs.f_symbol_assoc_list; i++)
  784.                 ASSOCIATED_SYMBOLS(sym)[i] =
  785.                   (char *) getsymref(ifile, "assoc-symbol-symref");
  786.         }
  787.     }
  788.     getrepr(ifile, sym);
  789.     if (S_SEGMENT(sym) == -1) S_SEGMENT(sym) = fs.f_symbol_s_segment;
  790.     if (S_OFFSET(sym) == 0)   S_OFFSET(sym) = fs.f_symbol_s_offset;
  791.     return sym;
  792. }
  793.  
  794.  
  795. Node getnodptr(int seq, int unit)        /*;getnodptr*/
  796. {
  797.     Tuple    nodptr;
  798.     Node    node;
  799.     /* here to convert seq and unit to pointer to symbol.
  800.      * we require that the symbol has already been allocated
  801.      */
  802.     /* TBSL: need to get SEQPTR table for unit, and return address
  803.      */
  804.     if (unit == 0) {
  805.         if (seq == 1) return OPT_NODE;
  806.         if (seq == 0) return (Node)0;
  807.         if (seq>0 && seq <= tup_size(init_nodes)) {
  808.             node = (Node) init_nodes[seq];
  809.             return node;
  810.         }
  811.         else {
  812.             chaos("error for unit 0 in getnodptr");
  813.         }
  814.     }
  815.     if (unit <= unit_numbers) {
  816.         struct unit *pUnit = pUnits[unit];
  817.         nodptr = (Tuple) pUnit->treInfo.tableAllocated;
  818.         if (seq == 0) chaos("getnodptr seq 0");
  819.         if (tup_size(nodptr) != pUnit->treInfo.nodeCount) {
  820.             /* this check is to avoid preallocation of node ptrs for all units
  821.              * in the library.
  822.              */
  823.             tup_free(nodptr);
  824.             nodptr = tup_new(pUnit->treInfo.nodeCount);
  825.             pUnit->treInfo.tableAllocated = (char *)nodptr;
  826.         }
  827.         if (seq <= pUnit->treInfo.nodeCount) {
  828.             node = (Node) nodptr[seq];
  829.             if (node == (Node)0) {/* here to allocate node on first reference */
  830.                 node = node_new_noseq(as_unread);
  831.                 N_SEQ(node) = seq;
  832.                 N_UNIT(node) = unit;
  833.                 nodptr[seq] = (char *) node;
  834.             }
  835.             return node;
  836.         }
  837.     }
  838.     chaos("getnodptr unable to find node");
  839.     return (Node) 0;    /* dummy return for lint's sake */
  840. }
  841.  
  842. Symbol getsymref(IFILE *ifile, char *desc)            /*;getsymref*/
  843. {
  844.     Symbol    sym;
  845.     int seq, unit;
  846.     seq = getnum(ifile, "sym-seq");
  847.     unit = getnum(ifile, "sym-unt");
  848.     sym = getsymptr(seq, unit);
  849. #ifdef DEBUG
  850.     if (trapss > 0 && trapss == seq && trapsu == unit) traps(sym);
  851. #endif
  852.     return sym;
  853. }
  854.  
  855. static void getudecl(IFILE *ifile, int ui)                /*;getudecl*/
  856. {
  857.     int i, n, ci, cn;
  858.     Tuple    tup, cent, ctup, cntup, symtup;
  859.     Symbol    usym;
  860.     Unitdecl    ud;
  861.  
  862.     ud = unit_decl_new();
  863.     pUnits[ui]->aisInfo.unitDecl = (char *) ud;
  864.     /* The second entry is the sequence of the symbol table entry
  865.      * identifying the unit. We use this sequence number to find
  866.      * the actual entry alread allocated.
  867.      */
  868.     usym = getsym(ifile, "ud-unam");
  869.     ud->ud_unam = usym;
  870.     ud->ud_useq = S_SEQ(usym);
  871.     ud->ud_unit = S_UNIT(usym);
  872.     get_unit_unam(ifile, usym);
  873.     /* context */
  874.     n = getnum(ifile, "decl-context-size");
  875.     if (n > 0) {
  876.         n -= 1; /* true tuple size */
  877.         ctup = tup_new(n);
  878.         for (i = 1; i <= n; i++) {
  879.             cent = (Tuple) tup_new(2);
  880.             cent[1] = (char *) getnum(ifile, "decl-ctup-1");
  881.             cn = getnum(ifile, "decl-cntup-size"); 
  882.             cntup = tup_new(cn);
  883.             for (ci = 1; ci <= cn; ci++)
  884.                 cntup[ci] = getstr(ifile, "decl-tupstr-str");
  885.             cent[2] = (char *) cntup;
  886.             ctup[i] = (char *) cent;
  887.         }
  888.         ud->ud_context =  ctup;
  889.     }
  890.     /* unit_nodes */
  891.     n = getnum(ifile, "decl-ud-nodes-size");
  892.     tup = tup_new(n);
  893.     for (i = 1; i <= n; i++) {
  894.         tup[i] = (char *) getnodref(ifile, "decl-nodref");
  895.     }
  896.     ud->ud_nodes = tup;
  897.     /* tuple of symbol table pointers */
  898.     n = getnum(ifile, "decl-tuple-size");
  899.     if (n > 0) {
  900.         n -= 1; /* true tuple size */
  901.         tup = tup_new(n);
  902.         for (i = 1; i <= n; i++) {
  903.             tup[i] = (char *) getsym(ifile, "decl-symref");
  904.         }
  905.         ud->ud_symbols = tup;
  906.     }
  907.     /* decscopes - tuple of scopes */
  908.     n = getnum(ifile, "decl-descopes-tuple-size");
  909.     if (n > 0) {
  910.         n -= 1; /* true tuple size */
  911.         symtup = tup_new(n);
  912.         for (i = 1; i <= n; i++) {
  913.             symtup[i] = (char *) getsym(ifile, "decl-decscopes-symref");
  914.         }
  915.         ud->ud_decscopes =    symtup;
  916.     }
  917.     /* decmaps - tuple of declared maps */
  918.     n = getnum(ifile, "decmaps-tuple-size");
  919.     if (n > 0) {
  920.         n -= 1; /* true tuple size */
  921.         tup = tup_new(n);
  922.         for (i = 1; i <= n; i++) {
  923. #ifdef TBSN
  924.             -- use decl maps read in with symbols    ds 21 dec 
  925.                 -- but read in anyway for completeness
  926. #endif
  927.             tup[i] = (char *) getdcl(ifile);
  928.             tup[i] = (char *) DECLARED((Symbol)symtup[i]);
  929.         }
  930.         ud->ud_decmaps = tup;
  931.     }
  932.     /* oldvis - tuple of unit names */
  933.     n = getnum(ifile, "vis");
  934.     if (n > 0) {
  935.         n -= 1; /* true tuple size */
  936.         tup = tup_new(n);
  937.         for (i = 1; i <= n; i++) {
  938.             tup[i] = getstr(ifile, "vis-str");
  939.         }
  940.         ud->ud_oldvis = tup;
  941.     }
  942.     return;
  943. }
  944.  
  945. char *read_ais(char *fname, int is_aic_file, char *uname,
  946.   int comp_index, int tree_is_needed)  /*;read_ais*/
  947. {
  948.     /* read aic or axq for unit with name uname from file fname.
  949.      * is_aic_file indicates whether we are reading from an aic or axq file.
  950.      * if uname is the null pointer, read 'comp_index'th unit from the file.
  951.      * return TRUE if read ok, FALSE if not. tree_is_needed is a flag to
  952.      * indicate whether retrieve_tree_nodes needs to be called. Is is always
  953.      * TRUE for the semantic phase and when called by the expander but is
  954.      * FALSE when called by BIND in the code generator.
  955.      */
  956.  
  957.     long    rec, genoff;
  958.     int        indx, fnum, unum, n, nodes, symbols, i, is_main_unit;
  959.     Tuple    symptr, tup, nodes_group;
  960.     Set        set;
  961.     struct unit *pUnit;
  962.     char    *funame, *retrieved ;
  963.     Unitdecl    ud;
  964.     IFILE    *ifile;
  965.     char    *lname, *tname, *full_fname;
  966.     int        is_predef; /* set when reading predef file */
  967.     /* Read information from the current compilation to
  968.      * 'file', restructuring the separate compilation maps
  969.      * to improve the readability of the AIS code.
  970.      */
  971.  
  972.     retrieved = NULL;
  973.     indx = 0;
  974.     is_predef = streq(fname, "0") && strlen(PREDEFNAME);
  975.     if (is_predef) {
  976.         /* reading predef, but not compiling it ! */
  977.         lname = libset(PREDEFNAME);
  978.         full_fname = "predef" ;
  979.     }
  980.     else {
  981.         full_fname = fname;
  982.     }
  983.     if (is_aic_file)
  984.         ifile = ifopen(full_fname, "aic", "r", 0);
  985.     else
  986.         ifile = ifopen(full_fname, "axq", "r", 0);
  987.     if (is_predef)
  988.         tname = libset(lname); /* restore library name after predef read */
  989.     for (rec=read_init(ifile); rec != 0; rec=read_next(ifile, rec)) {
  990.         indx++;
  991.         funame = getstr(ifile, "unit-name");
  992.         if (uname == NULL && indx != comp_index) continue;
  993.         if (uname != NULL  && streq(uname, funame) == 0) continue;
  994.         fnum = getnum(ifile, "unit-number");
  995.         unum = unit_number(funame);
  996.         if (unum != fnum) chaos("read_ais sequence number error");
  997.         pUnit = pUnits[unum];
  998.         genoff = getlong(ifile, "code-gen-offset");
  999.         is_main_unit = streq(unit_name_type(funame), "ma");
  1000.         if (!is_main_unit) { /* read only if NOT main unit (it has no ais info*/
  1001.             symbols = getnum(ifile, "seq-symbol-n");
  1002.             nodes = getnum(ifile, "seq-node-n");
  1003.             /* install tre node info and symbol count in the case where the
  1004.             *  generator reads semantic aisfile and therefore bypasses
  1005.             *  read_lib where the info is normally installed.
  1006.              */
  1007.             if (is_aic_file) {
  1008.                 pUnit->treInfo.nodeCount = nodes;
  1009.                 pUnit->treInfo.tableAllocated = (char *) tup_new(nodes);
  1010.                 pUnit->aisInfo.numberSymbols = symbols;
  1011.                 /* May be old value of aistup[7] may be freed at this point
  1012.                 *  of this is recompilation of unit within the last compilation.
  1013.                  */
  1014.                 pUnit->aisInfo.symbols = (char *) tup_new(symbols);
  1015.                 pUnit->libInfo.fname = AISFILENAME;
  1016.                 pUnit->libInfo.obsolete = string_ok;
  1017.             }
  1018.             symptr = (Tuple) pUnit->aisInfo.symbols;
  1019.             if (symptr == (Tuple)0) { /* if tuple not yet allocated */
  1020.                 symptr = tup_new(symbols);
  1021.                 pUnit->aisInfo.symbols = (char *) symptr;
  1022.             }
  1023.  
  1024.             /* ELABORATE PRAGMA INFO */
  1025.             n = getnum(ifile, "pragma-info-size");
  1026.             tup = tup_new(n);
  1027.             for (i = 1; i <= n; i++)
  1028.                 tup[i] = getstr(ifile, "pragma-info-value");
  1029.             pUnit->aisInfo.pragmaElab = (char *) tup;
  1030.             /* UNIT_DECL */
  1031.             getudecl(ifile, unum);
  1032.             /* PRE_COMP */
  1033.             n = getnum(ifile, "precomp-size");
  1034.             set = (Set) set_new(n);
  1035.             for (i = 1; i <= n; i++)
  1036.                 set = set_with(set, (char *) getnum(ifile, "precomp-value"));
  1037.             pUnit->aisInfo.preComp = (char *) set;
  1038.             /* tuple of symbol table pointers */
  1039.             aisunits_read = tup_with(aisunits_read, funame);
  1040.         }
  1041.         retrieved = funame;
  1042.         break;
  1043.     }
  1044.     if (tree_is_needed && retrieved) {
  1045.         ud = (Unitdecl) pUnit->aisInfo.unitDecl;
  1046.         tup = (Tuple) ud->ud_nodes;
  1047.         n = tup_size(tup);
  1048.         nodes_group = tup_new(n);
  1049.         for (i = 1; i <= n; i++)
  1050.             nodes_group[i] = (char *) N_SEQ((Node)tup[i]);
  1051.         retrieve_tree_nodes(ifile, unum, nodes_group);
  1052.     }
  1053.     ifclose(ifile);
  1054.     return retrieved;
  1055. }
  1056.  
  1057. int read_stub(char *fname, char *uname, char *ext)                /*;read_stub*/
  1058. {
  1059.     long    rec;
  1060.     Stubenv    ev;
  1061.     int        i, j, k, n, m, si;
  1062.     char    *funame;
  1063.     Tuple    stubtup, tup, tup2, tup3;
  1064.     int        ci, cn;
  1065.     int        parent_unit;
  1066.     Tuple    cent, ctup, cntup, nodes_group;
  1067.     Symbol    sym;
  1068.     int        retrieved = FALSE;
  1069.     IFILE    *ifile;
  1070.  
  1071.     /* open so do not fail if no file */
  1072.     ifile = ifopen(fname, ext, "r", 1);
  1073.     if (ifile == (IFILE *)0) return retrieved; /* if not stub file */
  1074.     
  1075.     for (rec = read_init(ifile); rec != 0; rec=read_next(ifile, rec)) {
  1076.         funame = getstr(ifile, "stub-name");
  1077.         if (uname != NULL  && !streq(uname, funame)) continue;
  1078.         si = stub_number(funame);
  1079.         if (uname == NULL) lib_stub_put(funame, fname);
  1080.         ev = stubenv_new();
  1081.         stubtup = (Tuple) stub_info[si];
  1082.         stubtup[2] = (char *) ev;
  1083.         n = getnum(ifile, "scope-stack-size");
  1084.         tup = tup_new(n);
  1085.         for (i = 1; i <= n; i++) {
  1086.             tup2 = tup_new(4);
  1087.             tup2[1] = (char *) getsymref(ifile, "scope-stack-symref");
  1088.             for (j = 2; j <= 4; j++) {
  1089.                 m = getnum(ifile, "scope-stack-m");
  1090.                 tup3 = tup_new(m);
  1091.                 for (k=1; k <= m; k++)
  1092.                     tup3[k] = (char *) getsymref(ifile, "scope-stack-m-symref");
  1093.                 tup2[j] = (char *) tup3;
  1094.             }
  1095.             tup[i] = (char *) tup2;
  1096.         }
  1097.         ev->ev_scope_st = tup;
  1098.         ev->ev_unit_unam = getsymref(ifile, "ev-unit-name-symref");
  1099.         ev->ev_decmap = getdcl(ifile);
  1100.  
  1101.         /* unit_nodes */
  1102.         n = getnum(ifile, "ev-nodes-size");
  1103.         tup = tup_new(n);
  1104.         for (i = 1; i <= n; i++) {
  1105.             tup[i] = (char *) getnodref(ifile, "ev-nodes-nodref");
  1106.         }
  1107.         ev->ev_nodes = tup;
  1108.  
  1109.         /* context */
  1110.         n = getnum(ifile, "stub-context-size");
  1111.         if (n > 0) {
  1112.             n -= 1; /* true tuple size */
  1113.             ctup = tup_new(n);
  1114.             for (i = 1; i <= n; i++) {
  1115.                 cent = (Tuple) tup_new(2);
  1116.                 cent[1] = (char *) getnum(ifile, "stub-cent-1");
  1117.                 cn = getnum(ifile, "stub-cent-2-size"); 
  1118.                 cntup = tup_new(cn);
  1119.                 for (ci = 1; ci <= cn; ci++)
  1120.                     cntup[ci] = getstr(ifile, "stub-cent-2-str");
  1121.                 cent[2] = (char *) cntup;
  1122.                 ctup[i] = (char *) cent;
  1123.             }
  1124.             ev->ev_context =  ctup;
  1125.         }
  1126.         /* tuple of symbol table pointers */
  1127.         /* read in but ignore symbol table references. This is for
  1128.          * read_stub_short so that the generator can rewrite the stubfile
  1129.          * without reading in full symbol table info from semantics phase.
  1130.          */
  1131.         n = getnum(ifile, "ev-decls-refs-size");
  1132.         if (n > 0) {
  1133.             n -= 1; /* true tuple size */
  1134.             for (i = 1; i <= n; i++)
  1135.                 sym = getsymref(ifile, "ev-decls-sym-ref");
  1136.         }
  1137.         /* tuple of symbol table pointers */
  1138.         n = getnum(ifile, "ev-open-decls-size");
  1139.         if (n > 0) {
  1140.             n -= 1; /* true tuple size */
  1141.             tup = tup_new(n);
  1142.             for (i = 1; i <= n; i++) {
  1143.                 sym = getsym(ifile, "ev-open-decls-sym");
  1144. /*
  1145.     if (NATURE(sym) == na_package || NATURE(sym) == na_procedure) {
  1146.         sym_temp = sym_new_noseq(na_void);
  1147.         sym_copy(sym_temp, sym);
  1148.         tup[i] = (char *) sym_temp;
  1149.     }
  1150.     else {
  1151.         tup[i] = (char *) sym;
  1152.      }
  1153. */
  1154.                 tup[i] = (char *) sym;
  1155.             }
  1156.             ev->ev_open_decls = tup;
  1157.         }
  1158.         ev->ev_current_level = getnum(ifile, "ev-current-level");
  1159.         /* tuple of relay-set symbols */
  1160.         n = getnum(ifile, "ev-relay-set-size");
  1161.         if (n > 0) {
  1162.             n -= 1; /* true tuple size */
  1163.             tup = tup_new(n);
  1164.             for (i = 1; i <= n; i++) {
  1165.                 tup[i] = (char *) getsymref(ifile, "relay-set-sym");
  1166.             }
  1167.             ev->ev_relay_set = tup;
  1168.         }
  1169.         else {
  1170.             ev->ev_relay_set = tup_new(0);
  1171.         }
  1172.         /* tuple of dang-relay-set symbols */
  1173.         n = getnum(ifile, "ev-dang-relay-set-size");
  1174.         if (n > 0) {
  1175.             n -= 1; /* true tuple size */
  1176.             tup = tup_new(n);
  1177.             for (i = 1; i <= n; i++)
  1178.                 tup[i] = (char *) getnum(ifile, "dang-relay-set-ent");
  1179.             ev->ev_dangling_relay_set = tup;
  1180.         }
  1181.         else {
  1182.             ev->ev_dangling_relay_set = tup_new(0);
  1183.         }
  1184.         retrieved = TRUE;
  1185.         if (uname != NULL)  break;
  1186.     }
  1187.     if (retrieved)  {
  1188.         tup = ev->ev_nodes;
  1189.         n = tup_size(tup);
  1190.         nodes_group = tup_new(n);
  1191.         for (i = 1; i <= n; i++)
  1192.             nodes_group[i] = (char *) N_SEQ((Node)tup[i]);
  1193.         parent_unit = stub_parent_get(funame);
  1194.         retrieve_tree_nodes(ifile, parent_unit, nodes_group);
  1195.     }
  1196.     ifclose(ifile);
  1197.     return retrieved;
  1198. }
  1199.  
  1200. int read_lib()                    /*;read_lib*/
  1201. {
  1202.     int        comp_status, si, i, j, n, m, nodes, symbols, cur_level;
  1203.     int        parent, unit_count;
  1204.     Tuple    stubtup, tup;
  1205.     struct unit *pUnit;
  1206.     char    *uname, *aisname, *tmp_str, *parent_name, *compdate;
  1207.     IFILE    *ifile;
  1208.  
  1209.     ifile = LIBFILE;
  1210.     /* note that library file opened by lib_aisname */
  1211.     unit_count = getnum(ifile, "lib-unit-count");
  1212.     n = getnum(ifile, "lib-n");
  1213.     empty_unit_slots = getnum(ifile, "lib-empty-slots");
  1214.     tmp_str = getstr(ifile, "tmp-str");
  1215.     unit_number_expand(n);
  1216.     for (i = 1;i <= unit_count; i++) {
  1217.         uname = getstr(ifile, "lib-unit-name");
  1218.         pUnit = pUnits[getnum(ifile, "lib-unit-number")];
  1219.         aisname = getstr(ifile, "lib-ais-name");
  1220.         compdate = getstr(ifile, "comp-date");
  1221.         symbols = getnum(ifile, "lib-symbols");
  1222.         nodes = getnum(ifile, "lib-nodes");
  1223.         pUnit->name = strjoin(uname, "");
  1224.         pUnit->isMain = getnum(ifile, "lib-is-main");
  1225.         comp_status = getnum(ifile, "lib-status");
  1226.         pUnit->libInfo.fname = strjoin(aisname, "");
  1227.         pUnit->libInfo.obsolete = (comp_status) ? string_ok: string_ds ;
  1228.         pUnit->libUnit = (comp_status) ? strjoin(uname, "") : string_ds;
  1229.         pUnit->aisInfo.numberSymbols = symbols;
  1230.         pUnit->treInfo.nodeCount = nodes;
  1231.         pUnit->treInfo.tableAllocated = (char *) tup_new(0);
  1232.     }
  1233.     n = getnum(ifile, "lib-n");
  1234.     for (i = 1;i <= n; i++) {
  1235.         uname = getstr(ifile, "lib-unit-name");
  1236.         aisname = getstr(ifile, "lib-ais-name");
  1237.         lib_stub_put(uname, strjoin(aisname, ""));
  1238.         parent = getnum(ifile, "lib-parent");
  1239.         if (parent == 0) parent_name = " ";
  1240.         else parent_name = pUnits[parent]->name;
  1241.         stub_parent_put(uname, parent_name);
  1242.         cur_level = getnum(ifile, "lib-cur-level");
  1243.         current_level_put(uname, cur_level);
  1244.         /* the following is the associated symbol for a package stub */
  1245.         si = stub_numbered(uname);
  1246.         stubtup = (Tuple) stub_info[si];
  1247.         m = getnum(ifile, "stub-file-size");
  1248.         tup = tup_new(m);
  1249.         for (j = 1;j <= m;j++)
  1250.             tup[j] = (char *) getnum(ifile, "stub-file");
  1251.         stubtup[4] = (char *) tup;
  1252.     }
  1253.     ifclose(LIBFILE);
  1254.     LIBFILE = (IFILE *) 0;
  1255.     return(unit_count);
  1256.  
  1257.     /* read out LIB_STUB map (always empty for now) */
  1258. }
  1259.  
  1260. void load_tre(IFILE *ifile, int comp_index)                        /*;load_tre*/
  1261. {
  1262.     /* load entire tree file. */
  1263.  
  1264.     long    rec, *off;
  1265.     int        i, fnum, unum, n, nodes, rootseq;
  1266.     char    *funame; 
  1267.  
  1268.     i=0;
  1269.     for (rec=read_init(ifile); rec!=0; rec=read_next(ifile, rec)) {
  1270.         i++;
  1271.         if (i != comp_index) continue;
  1272.         funame = getstr(ifile, "unit-name");
  1273.         fnum = getnum(ifile, "unit-number");
  1274.         unum = unit_number(funame);
  1275.         if (unum!=fnum)
  1276.             chaos("load_tre sequence number error");
  1277.         nodes = getnum(ifile, "node-count");
  1278.         /* the rest of the tree info is set in read_ais. Perhaps all can be
  1279.          * done there.
  1280.          */
  1281.         off= (long *)ecalloct((unsigned)nodes+1,sizeof(long),"load-tree-tup-3");
  1282.         fread((char *) off, sizeof(long), nodes+1, ifile->fh_file);
  1283.         rootseq = getnum(ifile, "root-seq");
  1284.         pUnits[unum]->treInfo.rootSeq = rootseq;
  1285.         for (n = 1; n <= nodes; n++) {
  1286.             if (off[n] == 0) { /* node not needed */
  1287.                    continue;
  1288.             }
  1289.             else {
  1290.                    ifseek(ifile, "seek-node", off[n], 0);
  1291.                    getnod(ifile, "unit-node", getnodptr(n, unum), unum);
  1292.             }
  1293.         }
  1294.         break;
  1295.     }
  1296.     tup_free((Tuple) off);
  1297.     ifclose(ifile);
  1298. }
  1299.  
  1300. static Tuple add_tree_node(Tuple tup, Node nod)                /*;add_tree_nodes */
  1301. {
  1302.     int        seq;
  1303.  
  1304.     if (nod == (Node)0 || nod == OPT_NODE) return tup;
  1305.     seq = N_SEQ(nod);
  1306.     if (tup_mem((char *) seq, tup)) return tup;
  1307.     tup = tup_with(tup, (char *) seq);
  1308.     return tup;
  1309. }
  1310.  
  1311. static void retrieve_tree_nodes(IFILE *ifile,
  1312.   int node_unit, Tuple nodes_list)   /*;retrieve_tree_nodes*/
  1313. {
  1314.     long    rec, *off;
  1315.     int        unum, items;
  1316.     int        node_seq, nkind;
  1317.     char      *fname;
  1318.     char    *tfname;
  1319.     Node    fn, nd;
  1320.     Fortup    ft1;
  1321.     char    *lname, *tname;
  1322.  
  1323.     /* read tree file for unit with unit number "node_unit" and load only
  1324.      * the nodes in nodes_list.
  1325.      */
  1326.  
  1327.     fname = lib_unit_get(pUnits[node_unit]->name);
  1328.     if (streq(fname, "0") && !streq(PREDEFNAME, "")) {
  1329.         /* reading predef, but not compiling it ! */
  1330.         lname = libset(PREDEFNAME);
  1331.         tfname = "predef";
  1332.     }
  1333.     else {
  1334.         tfname = fname;
  1335.     }
  1336.     ifile = ifopen(tfname, "trc", "r", 0);
  1337.     if (streq(fname, "0") && !streq(PREDEFNAME, ""))
  1338.         tname= libset(lname); /* restore library name */
  1339.  
  1340.     for (rec=read_init(ifile); rec != 0; rec=read_next(ifile, rec)) {
  1341.         getstr(ifile, "unit_name"); /* skip over unit name */
  1342.         unum = getnum(ifile, "unit-number");
  1343.         if (unum != node_unit) continue;
  1344.         items = getnum(ifile, "node-count");
  1345.         off = (long *) ecalloct((unsigned)items+1, sizeof(long), "read-tree");
  1346.         fread((char *) off, sizeof(long), items+1, ifile->fh_file);
  1347.         break;
  1348.     }
  1349.     while (tup_size(nodes_list)) {
  1350.         node_seq = (int) tup_frome(nodes_list);
  1351.         ifseek(ifile, "seek-node", off[node_seq], 0);
  1352.         fn = getnodptr(node_seq, node_unit);
  1353.         getnod(ifile, "unit-node", fn, unum);
  1354.  
  1355.         nkind = N_KIND(fn);
  1356.         if (N_AST1_DEFINED(nkind) && N_AST1(fn) != (Node)0)
  1357.             nodes_list = add_tree_node(nodes_list, N_AST1(fn));
  1358.         if (N_AST2_DEFINED(nkind) && N_AST2(fn) != (Node)0)
  1359.             nodes_list = add_tree_node(nodes_list, N_AST2(fn));
  1360.         if (N_AST3_DEFINED(nkind) && N_AST3(fn) != (Node)0)
  1361.             nodes_list = add_tree_node(nodes_list, N_AST3(fn));
  1362.         if (N_AST4_DEFINED(nkind) && N_AST4(fn) != (Node)0)
  1363.             nodes_list = add_tree_node(nodes_list, N_AST4(fn));
  1364.  
  1365.         if (N_LIST_DEFINED(N_KIND(fn)) && N_LIST(fn) != (Tuple)0) {
  1366.             FORTUP(nd=(Node), N_LIST(fn), ft1);
  1367.             nodes_list = add_tree_node(nodes_list, nd);
  1368.             ENDFORTUP(ft1);
  1369.         }
  1370.     }
  1371.     tup_free((Tuple) off);
  1372.     tup_free(nodes_list);
  1373.     ifclose(ifile);
  1374. }
  1375.  
  1376. void retrieve_generic_tree(Node node1, Node node2)    /*;retrieve_generic_tree*/
  1377. {
  1378.     Tuple    tup;
  1379.     int        unum;
  1380.  
  1381.     /* Bring in the part of the tree corresponding to a generic package spec
  1382.      * or body, or a generic subprogram body.
  1383.      * When node2 is not 0 it is the case of generic packages and node1
  1384.      * represent the decls_node and node2 represents the priv_node. Otherwise
  1385.      * node1 represents the body_node.
  1386.      */
  1387.     if (N_KIND(node1) ==  as_unread) {
  1388.         tup = tup_new1((char *) N_SEQ(node1));
  1389.     }
  1390.     else {
  1391.         tup = tup_new(0);
  1392.     }
  1393.     if (node2 != (Node)0 && N_KIND(node2) == as_unread) {
  1394.         tup = tup_with(tup, (char *) N_SEQ(node2));
  1395.     }
  1396.     if (tup_size(tup) != 0) {
  1397.         unum = N_UNIT(node1);
  1398.         retrieve_tree_nodes((IFILE *)0, unum, tup);
  1399.     }
  1400. }
  1401.  
  1402. char *lib_aisname()                                        /*;lib_aisname*/
  1403. {
  1404.     int        n, f_num, unit_count;
  1405.     char    *tmp_str, temp_str[4];
  1406.     char    *aisfilename;
  1407.     long    spos;
  1408.     IFILE    *ifile;
  1409.  
  1410.     /* Get name for next ais file from library. The offset within the
  1411.      * library file is not changed.
  1412.      */
  1413.     /* should have last arg nonzero to avoid crash if lib does not exist
  1414.      * and then issue error message
  1415.      */
  1416.  
  1417.     LIBFILE = ifopen(LIBFILENAME, "", "r", 0);
  1418.     ifile = LIBFILE;
  1419.     spos = iftell(ifile); /* get current offset in file */
  1420.     unit_count = getnum(ifile, "lib-unit-count");
  1421.     n = getnum(ifile, "lib-n");
  1422.     empty_unit_slots = getnum(ifile, "lib-empty-slots");
  1423.     tmp_str = getstr(ifile, "tmp-str");
  1424.     sscanf(tmp_str, "%d", &f_num);
  1425.     f_num++;
  1426.     sprintf(temp_str, "%d", f_num);
  1427.     aisfilename = strjoin(temp_str, "");
  1428.     /* restore to entry value of file offset */
  1429.     ifseek(ifile, "lib-start", spos, 0);
  1430.     return aisfilename;
  1431. }
  1432.  
  1433. void get_unit_unam(IFILE *ifile, Symbol sym)            /*;get_unit_unam*/
  1434. /*  
  1435.  * reads the full symbol definitions of the associated symbol field of the
  1436.  * unit name symbol. This is needed since when binding is done we want to
  1437.  * load the symbols from this field which represent the procedures to 
  1438.  * elaborate packages.
  1439.  */
  1440. {
  1441.     int    i;
  1442.  
  1443.     for (i = 1;i <= 3; i++)
  1444.         getsym(ifile, "ud-assoc-sym");
  1445. }
  1446.